home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / cmu-low.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  6KB  |  163 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;; 
  27. ;;; This is the CMU Lisp version of the file low.
  28. ;;; 
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defun function-ftype-declaimed-p (name)
  33.   "Returns whether the function given by name already has its ftype declaimed."
  34.   (multiple-value-bind (ftype-info recorded-p)
  35.       (extensions:info function type name)
  36.     (declare (ignore ftype-info))
  37.     recorded-p))
  38.  
  39. (defmacro dotimes ((var count &optional (result nil)) &body body)
  40.   `(lisp:dotimes (,var (the index ,count) ,result)
  41.      (declare (type index ,var))
  42.      ,@body))
  43.  
  44. ;;; Just use our without-interrupts.  We don't have the INTERRUPTS-ON/OFF local
  45. ;;; macros spec'ed in low.lisp, but they aren't used.
  46. ;;;
  47. (defmacro without-interrupts (&rest stuff)
  48.   `(sys:without-interrupts ,@stuff))
  49.  
  50.  
  51. ;;; Print the object addr in default printers.
  52. ;;;
  53. (defun printing-random-thing-internal (thing stream)
  54.   (format stream "{~X}" (sys:%primitive c:make-fixnum thing)))
  55.  
  56.  
  57. (eval-when (compile load eval)
  58.   (c:def-source-transform std-instance-p (x)
  59.     (ext:once-only ((n-x x))
  60.       `(and (ext:structurep ,n-x)
  61.             (eq (kernel:structure-ref ,n-x 0) 'std-instance)))))
  62.  
  63.   ;;   
  64. ;;;;;; Cache No's
  65.   ;;  
  66.  
  67. (proclaim '(inline object-cache-no))
  68.  
  69. (defun object-cache-no (symbol mask)
  70.   (logand (ext:truly-the fixnum (system:%primitive make-fixnum symbol))
  71.           (the fixnum mask)))
  72.  
  73.  
  74. (defun function-arglist (fcn)
  75.   "Returns the argument list of a compiled function, if possible."
  76.   (cond ((symbolp fcn)
  77.          (when (fboundp fcn)
  78.            (function-arglist (symbol-function fcn))))
  79.         ((eval:interpreted-function-p fcn)
  80.          (eval:interpreted-function-arglist fcn))
  81.         ((functionp fcn)
  82.          (let ((lambda-expr (function-lambda-expression fcn)))
  83.            (if lambda-expr
  84.                (cadr lambda-expr)
  85.                (let ((function (kernel:%closure-function fcn)))
  86.                  (values (read-from-string
  87.                           (kernel:%function-header-arglist function)))))))))
  88.  
  89.  
  90. ;;; We have this here and in fin.lisp, 'cause PCL wants to compile this
  91. ;;; file first.
  92. ;;; 
  93. (defsetf funcallable-instance-name set-funcallable-instance-name)
  94.  
  95. ;;; And returns the function, not the *name*.
  96. (defun set-function-name (fcn new-name)
  97.   "Set the name of a compiled function object."
  98.   (cond ((symbolp fcn)
  99.          (set-function-name (symbol-function fcn) new-name))
  100.         ((funcallable-instance-p fcn)
  101.          (setf (funcallable-instance-name fcn) new-name)
  102.          fcn)
  103.         ((eval:interpreted-function-p fcn)
  104.          (setf (eval:interpreted-function-name fcn) new-name)
  105.          fcn)
  106.         (t
  107.          (let ((header (kernel:%closure-function fcn)))
  108.            (system:%primitive c::set-function-name header new-name))
  109.          fcn)))
  110.  
  111. (in-package "C")
  112.  
  113. ;;From compiler/ir1util
  114. (def-source-context pcl::defmethod (name &rest stuff)
  115.   (declare (type list stuff))
  116.   (let ((arg-pos (position-if #'listp stuff)))
  117.     (declare (type (or null index) arg-pos))
  118.     (if arg-pos
  119.     `(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos)
  120.        ,(nth-value 2 (pcl::parse-specialized-lambda-list
  121.               (elt stuff arg-pos))))
  122.     `(pcl::defmethod ,name "<illegal syntax>"))))
  123.  
  124.  
  125. (in-package 'pcl)
  126.  
  127. (pushnew :structure-wrapper *features*)
  128. (pushnew :structure-functions *features*)
  129.  
  130. (import 'ext:structurep)
  131.  
  132. (defmacro structure-type (x)
  133.   `(kernel:structure-ref ,x 0))
  134.  
  135. (defun known-structure-type-p (type)
  136.   (not (null (ext:info c::type c::defined-structure-info type))))
  137.  
  138. (defun structure-type-included-type-name (type)
  139.   (let ((include (c::dd-include (ext:info c::type c::defined-structure-info type))))
  140.     (if (consp include)
  141.     (car include)
  142.     include)))
  143.  
  144. (defun structure-type-slot-description-list (type)
  145.   (nthcdr (length (the list
  146.                        (let ((include (structure-type-included-type-name type)))
  147.                  (and include (structure-type-slot-description-list include)))))
  148.       (c::dd-slots (ext:info c::type c::defined-structure-info type))))
  149.  
  150. (defun structure-slotd-name (slotd)
  151.   (intern (c::dsd-%name slotd) "USER"))
  152.  
  153. (defun structure-slotd-accessor-symbol (slotd)
  154.   (c::dsd-accessor slotd))
  155.  
  156. (defun structure-slotd-reader-function (slotd)
  157.   (fdefinition (c::dsd-accessor slotd)))
  158.  
  159. (defun structure-slotd-writer-function (slotd)
  160.   (unless (c::dsd-read-only slotd)
  161.     (fdefinition `(setf ,(c::dsd-accessor slotd)))))
  162.  
  163.